home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / parse / astutil.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  8.1 KB  |  254 lines
  1. (* Copyright 1992 by AT&T Bell Laboratories *)
  2.  
  3. structure AstUtil:ASTUTIL = struct    
  4.  
  5. local
  6.   open Symbol Fixity Ast ErrorMsg Symbol PrintUtil Modules Fixity 
  7. in
  8.  
  9. type parseEnv = Modules.env
  10.  
  11. val unitPat = RecordPat{def=nil,flexibility=false}
  12. val unitExp = RecordExp nil
  13. val trueDcon = [varSymbol "true"]
  14. val falseDcon = [varSymbol "false"]
  15. val nilDcon = [varSymbol "nil"]
  16. val consDcon = [varSymbol "::"]
  17. val quoteDcon = [varSymbol "QUOTE"]
  18. val antiquoteDcon = [varSymbol "ANTIQUOTE"]
  19. val truePat = VarPat(trueDcon)
  20. val trueExp = VarExp(trueDcon)
  21. val falsePat = VarPat(falseDcon)
  22. val falseExp = VarExp(falseDcon)
  23. val nilPat = VarPat(nilDcon)
  24. val nilExp = VarExp(nilDcon)
  25. val consPat = fn pat => AppPat{constr=consDcon,argument=pat}
  26. val consExp = VarExp(consDcon)
  27. val arrowTycon = tycSymbol "->"
  28. val exnID = Symbol.tycSymbol "exn"
  29. val bogusID = varSymbol "BOGUS"
  30. val symArg = strSymbol "<Parameter>"
  31. val itsym = [varSymbol "it"]
  32.  
  33.  
  34. (* list expression *)
  35. fun ListExp l =
  36.   fold (fn (e,rest) => AppExp{function=consExp,argument=TupleExp[e,rest]})
  37.        l nilExp
  38.  
  39. (* list pattern *)
  40. fun ListPat l =
  41.   fold (fn (e,rest) => AppPat{constr=consDcon, argument=TuplePat[e,rest]})
  42.        l nilPat
  43.  
  44. (* THE PRECEDENCE PARSER *)
  45.  
  46.  
  47. (* THE PRECEDENCE PARSER *)
  48.  
  49. (* internal type for the precedence stack *)
  50. abstype 'a precStack = INf of int * 'a * 'a precStack
  51.            | NONf of 'a * 'a precStack
  52.            | NILf
  53. with 
  54.  
  55. fun precedence (app,pair) =
  56.   
  57.  let (* verifies it is non fix *)
  58.      fun ensure_nonfix (e,NONfix,_) = e
  59.        | ensure_nonfix (e,INfix _,err) = 
  60.       (err COMPLAIN "nonfix identifier required" nullErrorBody; e)
  61.  
  62.      (* starts the parser *)
  63.      fun start(e,f,err) = NONf(ensure_nonfix(e,f,err), NILf)
  64.  
  65.      (* parse an expression *)
  66.      fun parse(NONf(e,r), e',NONfix,err) = NONf(app err(e,e'),r)
  67.        | parse(p as INf _, x,f,err) = NONf(ensure_nonfix(x,f,err), p)
  68.        | parse(p as NILf, _,_,err) = impossible "Corelang.parse NILf"
  69.        | parse(p as NONf(e1,INf(bp,e2,NONf(e3,r))), e4, f as INfix(lbp,rbp),err)=
  70.         if lbp > bp then INf(rbp,e4,p)
  71.          else (if lbp = bp
  72.             then err WARN "mixed left- and right-associative \
  73.                       \operators of same precedence"
  74.                      nullErrorBody
  75.             else ();
  76.                parse(NONf(app err(e2,pair err (e3,e1)),r),e4,f,err))
  77.        | parse(p as NONf _, e',INfix(lbp,rbp),_) = INf(rbp,e',p)
  78.      
  79.      (* clean up the stack *)
  80.      fun finish (NONf(e1,INf(_,e2,NONf(e3,r))),err) = 
  81.              finish(NONf(app err(e2,pair err (e3,e1)),r),err)
  82.        | finish (NONf(e1,NILf),_) = e1
  83.        | finish (INf(_,e1,NONf(e2,p)),err) = 
  84.              (err COMPLAIN "nonfix identifier required" nullErrorBody;
  85.               finish(NONf(app err(e2,e1),p),err))
  86.        | finish (NILf,err) = impossible "Corelang.finish NILf"
  87.        | finish _ = ErrorMsg.impossible "Corelang.finish"
  88.  
  89.   in {start=start,parse=parse,finish=finish}
  90.  end
  91. end
  92.  
  93. fun lookFIX(env,name) = (
  94.   case Env.look(env,name) 
  95.   of FIXbind(FIXvar{binding,...}) => binding
  96.    | _ => impossible "lookFIX")
  97.   handle Env.Unbound => NONfix
  98.  
  99. fun checkFix(int,err) =
  100.     if 0 <= int andalso int <= 9
  101.         then int
  102.         else (err COMPLAIN "fixity precedence must be between 0 and 9"
  103.               nullErrorBody;
  104.           9)
  105.  
  106. (* Parsing expressions *)
  107. val {start=exp_start, parse=exp_parse, finish=exp_finish} = 
  108.     precedence(fn _ => fn(f,a) => AppExp{function=f,argument=a},
  109.            fn _ => fn (a,b) => TupleExp[a,b])
  110.  
  111. fun apply_pat err (VarPat d ,p) = AppPat{constr=d, argument=p}
  112.   | apply_pat err _ = 
  113.     (err COMPLAIN "non-constructor applied to argument in pattern"
  114.          nullErrorBody;
  115.      WildPat)
  116.  
  117. val {start=pat_start, parse=pat_parse0, finish=pat_finish} =
  118.     precedence(apply_pat, 
  119.            fn err => fn (ap1,ap2) => TuplePat[ap1,ap2])
  120.  
  121. fun pat_parse(ap,(p,f,err)) = pat_parse0(ap, p, f,err)
  122.  
  123. (* verifies unicity of elements in a list *)
  124. fun checkUniq (err,message) l =
  125.  let val l' = Sort.sort Symbol.symbolGt l
  126.      fun f (x::y::rest) = (if Symbol.eq(x,y) 
  127.                   then err COMPLAIN(message^ ": " ^ Symbol.name x)
  128.                        nullErrorBody
  129.                   else ();
  130.                f(y::rest))
  131.       | f _ = ()
  132.   in f l' end
  133.  
  134. (* layered patterns *)
  135. fun layered((x as VarPat _), y, _) = LayeredPat{varPat=x,expPat=y}
  136.   | layered(ConstraintPat{pattern=x as VarPat _,constraint=t}, y, _) = 
  137.     LayeredPat{varPat=x,expPat=ConstraintPat{pattern=y,constraint=t}}
  138.   | layered(x,y,err) = (err COMPLAIN "pattern to left of AS must be variable"
  139.                 nullErrorBody;
  140.             y)
  141.  
  142. (* sequence of declarations *)
  143. fun makeSEQdec (d1,d2) env = 
  144.   let val (d1',f1) = d1 env
  145.       val (d2',f2) = d2 (f1 env)
  146.       val d' = 
  147.         case (d1',d2')
  148.         of (SeqDec a, SeqDec b) => SeqDec(a@b)
  149.          | (SeqDec a, b) => SeqDec(a@[b])
  150.          | (a, SeqDec b) => SeqDec(a::b)
  151.          | (a,b) => SeqDec[a,b]
  152.   in (d',f2 o f1) end
  153.  
  154. (* local declarations *)
  155. fun makeLOCALdec (ldecs1,ldecs2) env =
  156.   let val (ld1,f1) = ldecs1 env
  157.       val (ld2,f2) = ldecs2 (f1 env)
  158.   in (LocalDec(ld1,ld2),f2) end
  159.  
  160. (* let expressions *)
  161. fun makeLETstr (ldec,str) env =
  162.   let val (ld,f) = ldec env
  163.       val str = str (f env)
  164.   in LetStr (ld,str) end
  165.  
  166. fun makeLETfct (ldec,fct) env constraint =
  167.   let val (ld,f) = ldec env
  168.       val fct = fct((f env), constraint)
  169.   in LetFct (ld,fct) end
  170.  
  171. (* val rec declarations *)
  172. type rawrvb = {name:symbol,ty:ty option, match:parseEnv -> rule list }
  173.  
  174. fun makeVALRECdec (rvb,err) env =
  175.     let val rvbs = rvb env
  176.     fun makervb({name,ty,match,...}:rawrvb) =
  177.           Rvb{var=name,resultty=ty, exp=FnExp(match env)}
  178.     in (ValrecDec(map makervb rvbs),Env.empty) end
  179.  
  180. type rawclause = {name:symbol,pats:pat list,resultty:ty option,
  181.           exp:parseEnv -> exp, err: ErrorMsg.complainer}
  182.  
  183. (* verification of function declarations *)
  184.  
  185. fun checkFB(clauses as ({name,pats,...}:rawclause)::rest, err) = (
  186.       if exists (fn {name=n,...} => not(Symbol.eq(n,name))) rest
  187.       then err COMPLAIN "clauses don't all have same function-name"
  188.                nullErrorBody
  189.       else ();clauses)
  190.   | checkFB _ = ErrorMsg.impossible "CoreLang.checkFB"
  191.  
  192. fun make_app_pat((p as (_,_,err))::rest) =
  193.     let fun f(x,p::r) = f(pat_parse(x,p),r)
  194.       | f(x,nil) = pat_finish(x,err)
  195.      in f(pat_start p, rest)
  196.     end
  197.   | make_app_pat _ = ErrorMsg.impossible "make_app_pat"
  198.  
  199. fun checkpat(p,NONfix,_) = p
  200.   | checkpat(p,INfix _, err) =
  201.       (err COMPLAIN "NONfix pattern required" nullErrorBody;
  202.        p)
  203.  
  204. fun funsym(VarPat [id], err) = id
  205.   | funsym(_,err) = 
  206.       (err COMPLAIN "illegal function symbol in clause" nullErrorBody;
  207.        bogusID)
  208.  
  209. fun makecl(pats as _::_, [(a,INfix _,e), pat]) =
  210.         (funsym(a,e), [TuplePat[make_app_pat pats, checkpat pat]])
  211.   | makecl([(a,NONfix,_),(b,INfix _,e),(c,NONfix,_)],pats) =
  212.         (funsym(b,e), TuplePat[a,c] :: map checkpat pats)
  213.   | makecl([],[(a,NONfix,_),(b,INfix _,e),(c,NONfix,_)]) =
  214.         (funsym(b,e), [TuplePat[a,c]])
  215.   | makecl([],(a,NONfix,e)::(pats as _::_)) =
  216.         (funsym(a,e), map checkpat pats)
  217.   | makecl([],(a,INfix _,e)::(pats as _::_)) =
  218.         (e COMPLAIN "INfix operator used without 'op' in fun dec"
  219.            nullErrorBody;
  220.          (funsym(a,e), map checkpat pats))
  221.   | makecl(_,(_,_,e)::_) = (e COMPLAIN "can't find function symbol in fun dec"
  222.                   nullErrorBody;
  223.                 (bogusID,[WildPat]))
  224.   | makecl((_,_,e)::_,_) = (e COMPLAIN "can't find function symbol in fun dec"
  225.                   nullErrorBody;
  226.                 (bogusID,[WildPat]))
  227.   | makecl _ = ErrorMsg.impossible "CoreLang.makecl"
  228.  
  229. fun makeFUNdec (fb,err) env =
  230.     let fun makevar (p as ({name,...}:rawclause)::_,l1,l2) = (name,p,l1,l2)
  231.       | makevar _ = ErrorMsg.impossible "makeFUNdec.makevar"
  232.         val clauses = map makevar (fb env)
  233.     fun makeclause{name,pats,resultty,exp,err} =
  234.        Clause{pats=pats,resultty=resultty,exp=exp env}
  235.     fun evalclauses(v,l,l1,l2) = (v,map makeclause l,l1,l2)
  236.     val fbs = map evalclauses clauses
  237.     fun makefb (n,c,l1,l2) = MarkFb(Fb{var=n,clauses=c},l1,l2)
  238.      in (FunDec(map makefb fbs),fn x => x) end
  239.  
  240. fun makeFIXdec(fixity,ops) _ =
  241.   let fun bind (ident,env) =
  242.      Env.bind(ident,FIXbind(FIXvar{binding=fixity,name=ident}),env)
  243.   in (FixDec {fixity=fixity,ops=ops},revfold bind ops) end
  244.  
  245. fun toplevelexp(env,exp) =
  246.     (ValDec[Vb {exp = exp env, pat = VarPat itsym}],Env.empty)
  247.  
  248. fun QuoteExp s = AppExp{function=VarExp quoteDcon,argument=StringExp s}
  249. fun AntiquoteExp e = AppExp{function=VarExp antiquoteDcon,argument= e}
  250.  
  251. end (* local *)
  252. end (* structure *)
  253.  
  254.